unit SmallCRT;
{****************************************************************************
** Small CRT replacement unit                                              **
**   by Steven Don                                                         **
*****************************************************************************
** A unit to replace some of the functions of Turbo Pascal's CRT unit.     **
** The original CRT unit in the Borland runtime library contains a bug     **
** that causes runtime error 200 ("Divide by zero") on Pentium II and      **
** above. To prevent this bug from plaguing your programs, remove the      **
** "USES CRT" clause from your program and replace it with "USES SMALLCRT" **
**                                                                         **
** Unfortunately, it's not possible to recreate all of the original CRT    **
** unit's functions (most notably those to do with setting the text and    **
** background colour). For a list of available functions, see below.       **
**                                                                         **
** For questions, feel free to e-mail me.                                  **
**                                                                         **
**    shd@earthling.net                                                    **
**    http://shd.cjb.net                                                   **
**                                                                         **
****************************************************************************}

interface

{Constants available to the calling program}
const
  {Different text modes}
  BW40 = 0; {40x25 B/W}
  CO40 = 1; {40x25 Color}
  BW80 = 2; {80x25 B/W}
  CO80 = 3; {80x25 Color}

  TimeSlice = 100; {Threshold (in ms), above which Delay tries to give up
                      time slices. Can be changed.}

{Variables available to the calling program}
var
  {Last text mode}
  LastMode    : Word;

{Procedures available to the calling program}
procedure ClrScr;                        {Clears the screen and returns the cursor to the upper left corner.}
procedure Delay (MS : Word);             {Delays a specifed number of milliseconds.}
procedure GotoXY (X, Y : Byte);          {Moves the cursor to the given coordinates within the virtual screen.}
procedure HighVideo;                     {Selects high-intensity characters.}
function  KeyPressed : Boolean;          {Determines if a key has been pressed on the keyboard.}
procedure LowVideo;                      {Selects low-intensity characters.}
procedure NoSound;                       {Turns off the computer's internal speaker.}
function  ReadKey : Char;                {Reads a character from the keyboard.}
procedure Sound (Hz : Word);             {Starts the internal speaker.}
procedure TextMode (Mode : Integer);     {Selects a specific text mode.}
function  WhereX : Byte;                 {Returns the X coordinate of the current cursor location.}
function  WhereY : Byte;                 {Returns the Y coordinate of the current cursor location.}

implementation

var
  {For returning keys}
  KeyLeft     : Boolean;
  NextKey     : Char;
  {For timing}
  TicksPerMs  : LongInt;
  SystemClock : LongInt absolute $0000:$046C;

{*****************************************************************************
** INTERNAL ROUTINES                                                        **
*****************************************************************************}

{Stores the current display mode}
procedure InitMode;
var
  CurMode : Byte;

begin
  {Get mode register from graphics card}
  CurMode := Port [$3D8] and 15;
  {Translate into known constants}
  case CurMode of
     0 : LastMode := CO40;
     1 : LastMode := CO80;
     4 : LastMode := BW40;
     5 : LastMode := BW80;
  end;
end;

{*****************************************************************************
** MAIN ROUTINES                                                            **
*****************************************************************************}

{** CLRSCR ******************************************************************}
procedure ClrScr;
var
  Pos : Word;

begin
  {Clear memory, to grey on black}
  for Pos := 0 to 1999 do begin
    MemW [$B800:Pos shl 1] := $0700;
  end;

  {Return cursor to top left}
  GotoXY (1, 1);
end;

{** DELAY *******************************************************************}
PROCEDURE DelayLoop; NEAR; ASSEMBLER; {Internal!}
ASM
@1:SUB  AX,1
   SBB  DX,0
   JC   @2
   CMP  BL,ES:[DI]
   JE   @1
@2:
END;

PROCEDURE Delay(ms:Word); ASSEMBLER;
TYPE LongRec=RECORD Lo,Hi:Word END;
CONST DelayCnt:Longint=0; {0 means unitialized}
CONST op32=$66; {Prefix for 32bit operations}
ASM
   MOV  ES,Seg0040
   MOV  CX,ms
   MOV  SI,$6C
   MOV  AX,DelayCnt.LongRec.Lo
   OR   AX,DelayCnt.LongRec.Hi
   JNE  @2            { jump to delay loop if it's already initialized }
   MOV  DI,SI
   MOV  BL,ES:[DI]
@1:CMP  BL,ES:[DI]
   JE   @1            { wait until bios time counter ticks }
   MOV  BL,ES:[DI]
   MOV  AX,-28
   CWD
   CALL DelayLoop
   NOT  AX
   NOT  DX
   MOV  BX,AX
   MOV  AX,DX
   XOR  DX,DX
   MOV  CX,55
   DIV  CX
   MOV  DelayCnt.LongRec.Hi,AX
   MOV  AX,BX
   DIV  CX
   MOV  DelayCnt.LongRec.Lo,AX
   MOV  CX,ms
   SUB  CX,83
   JBE  @x
@2:JCXZ @x
   XOR  DI,DI
   MOV  BL,ES:[DI]
   CMP  Test8086,2
   JNB  @4
@3:XOR  SI,SI
@4:MOV  BH,ES:[SI]
@5:MOV  AX,DelayCnt.LongRec.Lo
   MOV  DX,DelayCnt.LongRec.Hi
   CALL DelayLoop
   CMP  BH,ES:[SI]
   JNE  @7
@6:LOOP @5
   JMP  @x
@7:CMP  CX,TimeSlice
   JB   @6
   DB   op32;MOV DX,ES:[SI]
@8:MOV  AX,$1680
   INT  $2F
   OR   AL,AL
   JNZ  @3
   DB   op32;MOV AX,DX
   DB   op32;MOV DX,ES:[SI]
   DB   op32;SUB AX,DX
   JBE  @9
   DB   op32;MOV AX,DX
   JMP  @a
@9:DB   op32;NEG AX
@a:DB   op32;CMP AX,$4A7;DW 0 {CMP EAX,$10000 DIV 55}
   JA   @x
   PUSH DX
   PUSH CX
   MOV  CX,55
   MUL  CX
   POP  CX
   POP  DX
   SUB  CX,AX
   JBE  @x
   CMP  CX,TimeSlice
   JNB  @8
   JMP  @3
@x:
END;

{** GOTOXY ******************************************************************}
procedure GotoXY (X, Y : Byte);
begin
  {Convert Pascal's coordinates to BIOS coordinates}
  Dec (X); Dec (Y);
  {Call BIOS to set cursor to other location}
  asm
    mov ax, 0200h
    mov bh, 0000h
    mov dh, Y
    mov dl, X
    int 0010h
  end;
end;

{** HIGHVIDEO ***************************************************************}
procedure HighVideo; assembler;
asm
  mov ax, 1003h
  mov bx, 0000h
  int 0010h
end;

{** KEYPRESSED **************************************************************}
function KeyPressed : Boolean;
var
  w : Word;

begin
  asm
    mov ax, 0100h
    int 0016h
    jnz @KeyWaiting
    mov ax, 0000h
  @KeyWaiting:
    mov w, ax
  end;
  KeyPressed := (w <> 0);
end;

{** LOWVIDEO ****************************************************************}
procedure LowVideo; assembler;
asm
  mov ax, 1003h
  mov bx, 0001h
  int 0010h
end;

{** NOSOUND *****************************************************************}
procedure NoSound; assembler;
asm
  in al, 0061h
  and al, 00FCh
  out 0061h, al
end;

{** READKEY *****************************************************************}
function ReadKey : Char;
var
  w : Word;

begin
  {If a key is still left over, return that}
  if (KeyLeft) then begin
    ReadKey := NextKey;
    KeyLeft := false;
    Exit;
  end;

  {Wait until a key has been pressed}
  repeat until KeyPressed;

  {Retrieve it}
  asm
    mov ax, 0000h
    int 0016h
    mov w, ax
  end;

  if (Lo (w) <> 0) then begin
    {If it's a simple key, return that}
    ReadKey := Chr (Lo (w));
  end else begin
    {If it's an extended key, first return 0}
    ReadKey := Chr (0);
    {Then, return the scan code}
    KeyLeft := true;
    NextKey := Chr (Hi (w));
  end;
end;

{** SOUND *******************************************************************}
procedure Sound (Hz : Word); assembler;
asm
  mov al, 00B6h
  out 0043h, al
  mov dx, 0014h
  mov ax, 4F38h
  div Hz
  out 0042h, al
  mov al, ah
  out 0042h, al
  in al, 0061h
  or al, 0003h
  out 0061h, al
end;

{** TEXTMODE ****************************************************************}
procedure TextMode (Mode : Integer);
begin
  {Store last video mode}
  InitMode;
  {Initialize new mode}
  asm
    mov ax, Mode
    int 0010h
  end
end;

{** WHEREX ******************************************************************}
function  WhereX : Byte;
var
  CursorX : Byte;

begin
  asm
    mov ax, 0300h
    mov bx, 0000h
    int 0010h
    mov CursorX, dl
  end;
  WhereX := CursorX + 1;
end;

{** WHEREY ******************************************************************}
function  WhereY : Byte;
var
  CursorY : Byte;

begin
  asm
    mov ax, 0300h
    mov bx, 0000h
    int 0010h
    mov CursorY, dh
  end;
  WhereY := CursorY + 1;
end;

begin
  InitMode;
  Delay (1); { call once for initialization }
{  InitDelay;}
end.